home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / cpp_libs / rwvector.lha / RWVector2.1 / src / mathpack / dpassb.f < prev    next >
Text File  |  1989-08-14  |  3KB  |  126 lines
  1.       subroutine dpassb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
  2. c
  3. c     Double precision version.  -tk
  4. c
  5. C***BEGIN PROLOGUE  DPASSB
  6. C***REFER TO DCFFTB
  7. C***ROUTINES CALLED  (NONE)
  8. C***END PROLOGUE  DPASSB
  9.       implicit double precision (a-h,o-z)
  10.       dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
  11.      1                c1(ido,l1,ip)          ,wa(1)      ,c2(idl1,ip),
  12.      2                ch2(idl1,ip)
  13. C***FIRST EXECUTABLE STATEMENT  DPASSB
  14.       idot = ido/2
  15.       nt = ip*idl1
  16.       ipp2 = ip+2
  17.       ipph = (ip+1)/2
  18.       idp = ip*ido
  19. C
  20.       if (ido .lt. l1) go to 106
  21.       do 103 j=2,ipph
  22.          jc = ipp2-j
  23.          do 102 k=1,l1
  24.             do 101 i=1,ido
  25.                ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
  26.                ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  27.   101       continue
  28.   102    continue
  29.   103 continue
  30.       do 105 k=1,l1
  31.          do 104 i=1,ido
  32.             ch(i,k,1) = cc(i,1,k)
  33.   104    continue
  34.   105 continue
  35.       go to 112
  36.   106 do 109 j=2,ipph
  37.          jc = ipp2-j
  38.          do 108 i=1,ido
  39.             do 107 k=1,l1
  40.                ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
  41.                ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  42.   107       continue
  43.   108    continue
  44.   109 continue
  45.       do 111 i=1,ido
  46.          do 110 k=1,l1
  47.             ch(i,k,1) = cc(i,1,k)
  48.   110    continue
  49.   111 continue
  50.   112 idl = 2-ido
  51.       inc = 0
  52.       do 116 l=2,ipph
  53.          lc = ipp2-l
  54.          idl = idl+ido
  55.          do 113 ik=1,idl1
  56.             c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
  57.             c2(ik,lc) = wa(idl)*ch2(ik,ip)
  58.   113    continue
  59.          idlj = idl
  60.          inc = inc+ido
  61.          do 115 j=3,ipph
  62.             jc = ipp2-j
  63.             idlj = idlj+inc
  64.             if (idlj .gt. idp) idlj = idlj-idp
  65.             war = wa(idlj-1)
  66.             wai = wa(idlj)
  67.             do 114 ik=1,idl1
  68.                c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
  69.                c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc)
  70.   114       continue
  71.   115    continue
  72.   116 continue
  73.       do 118 j=2,ipph
  74.          do 117 ik=1,idl1
  75.             ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
  76.   117    continue
  77.   118 continue
  78.       do 120 j=2,ipph
  79.          jc = ipp2-j
  80.          do 119 ik=2,idl1,2
  81.             ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
  82.             ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
  83.             ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
  84.             ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
  85.   119    continue
  86.   120 continue
  87.       nac = 1
  88.       if (ido .eq. 2) return
  89.       nac = 0
  90.       do 121 ik=1,idl1
  91.          c2(ik,1) = ch2(ik,1)
  92.   121 continue
  93.       do 123 j=2,ip
  94.          do 122 k=1,l1
  95.             c1(1,k,j) = ch(1,k,j)
  96.             c1(2,k,j) = ch(2,k,j)
  97.   122    continue
  98.   123 continue
  99.       if (idot .gt. l1) go to 127
  100.       idij = 0
  101.       do 126 j=2,ip
  102.          idij = idij+2
  103.          do 125 i=4,ido,2
  104.             idij = idij+2
  105.             do 124 k=1,l1
  106.                c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
  107.                c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  108.   124       continue
  109.   125    continue
  110.   126 continue
  111.       return
  112.   127 idj = 2-ido
  113.       do 130 j=2,ip
  114.          idj = idj+ido
  115.          do 129 k=1,l1
  116.             idij = idj
  117.             do 128 i=4,ido,2
  118.                idij = idij+2
  119.                c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
  120.                c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  121.   128       continue
  122.   129    continue
  123.   130 continue
  124.       return
  125.       end
  126.